home *** CD-ROM | disk | FTP | other *** search
/ El Mac 8 / El Mac 8.iso / Shareware / Applications / 4th Artificial Life / Afarm.4th next >
Encoding:
Text File  |  1996-03-15  |  2.8 KB  |  64 lines  |  [TEXT/MSWD]
  1. \ ****** Afarm  in  FORTH  by  MERVYN@xs4all.nl *******
  2. --> Extended.4th
  3. variable AT 1000 allot  variable EN 1000 allot  variable DE 1000 allot
  4. variable SP 1000 allot  variable REP 1000 allot
  5. variable SUN variable RISK variable PL variable GEN
  6. variable NPL variable FA variable FA0 variable FL variable FL0
  7. create "TITLE" ," Animal Farm"
  8. : INIT  BLACK bcolor WHITE fcolor  600 370 wsize  "TITLE" wtitle  page
  9.     EN 1000 0 fill  DE 1000 0 fill  AT 1000 0 fill  SP 1000 0 fill
  10.     REP 1000 0 fill randomize 0 GEN ! 0 FL ! 0 FA ! 2 EN 90 + ! 3 REP 90 + !
  11.     ." Animal Farm  by  Mervyn@xs4all.nl (programmed in Forth)" CR CR
  12.     ." Animal Farm is a program that can create the evolution " CR
  13.     ." of a biosystem consisting of entities with different features: " CR
  14.     ." e=energy a=attacking force d=defensive force  s=speed " CR
  15.     ." Character='specie': a+4*d+10*s -> 0-25=A-Z" CR 
  16.     ." Each step: e -> e+sun-(a+d+2s)     [+e(from attacked entity)]" CR
  17.     ." Flora=white     Fauna=red (s>0)" CR
  18.     ." Sun (free energy): "    key 48 - dup . SUN ! CR 
  19.     ." By means of mutation offspring can be differ from the parent." CR
  20.     ." Mutation risk (%): "     key 48 - RISK ! PAGE ;
  21. : MUT 100 RANDOM RISK @ < if 5 RANDOM 2 - else 0 then ;
  22. : NEWPOS 4 RANDOM
  23.     DUP 0= if     PL @ 2 - NPL !    drop else
  24.     DUP 1 = if     PL @ 2+ NPL !     drop else
  25.     DUP 2 = if     PL @ 40 - NPL !    drop else
  26.            3 = if     PL @ 40 + NPL !    then then then then
  27.     NPL @ DUP 0< if 800 NPL ! drop else
  28.                  800 > if 0 NPL ! then then ;
  29. : REPRIF
  30.     PL @ EN + @ 2/       NPL @ EN + !
  31.     PL @ EN + @ 2/        PL @ EN + !
  32.     PL @ DE + @ MUT +     NPL @ DE + !
  33.     PL @ AT + @ MUT +     NPL @ AT + !
  34.     PL @ SP + @ MUT +     NPL @ SP + !
  35.     PL @ REP + @ MUT +     NPL @ REP + ! ;
  36. : REPRODUCE  NEWPOS     NPL @ EN + @ 1     < if REPRIF
  37.     else PL @ AT + @       NPL @ DE + @     > if REPRIF then then ;
  38. : MOVE    
  39.     PL @ EN + @     NPL @ EN + !    PL @ AT + @    NPL @ AT + !
  40.     PL @ DE + @    NPL @ DE + !    PL @ SP + @    NPL @ SP + !
  41.     PL @ REP + @    NPL @ REP + !    0 PL @ EN + ! ;
  42. : COMPARE  PL @ AT + @ 1+  NPL @ DE + @ 
  43.     > if  NPL @ EN + @  PL @ EN + +!  MOVE then ;
  44. : VIEW 0 30 !PEN  760 0 Do  40 0 Do I J + PL !  
  45.     PL @ EN + @ 0> if 
  46.         PL @ SP + @ 0> if RED fcolor else WHITE fcolor then
  47.         65  PL @  AT + @ +      PL @ DE + @ 4 * +  
  48.         PL @ SP + @ 10 * +     ."  " emit else ."  ." then
  49.     2 +Loop  CR  40 +Loop 
  50.     RED fcolor GEN @ 360 FA0 @ 4 / - !PEN GEN @ 1+ 360 FA @ 4 / - -TO  
  51.     WHITE fcolor GEN @ 360 FL0 @ 4 / - !PEN GEN @ 1+ 360 FL @ 4 / - -TO ;
  52. : AFARM INIT Begin     FL @ FL0 ! FA @ FA0 ! 0 FL ! 0 FA !  1 GEN +! 
  53.     800 0 Do I PL ! I EN + @ 0> if
  54.         0 I SP + @ dabs 2* - I DE + @ dabs -  I AT + @ dabs - SUN @ +
  55.         I EN + +!
  56.         I EN + @ I REP + @ > if REPRODUCE then 
  57.         I SP + @ 0> if NEWPOS 1 FA +!
  58.             NPL EN + @ 1 < if MOVE 
  59.             else COMPARE then else 1 FL +! then then
  60.     2 +Loop VIEW ?BUTTON if QUIT then  Again ; 
  61. READY                            \ "echo on"
  62. AFARM                             \ "types AFARM to run itself"
  63.  
  64.